home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / schmlbrr / schem_lb.lha / unsupported / CScheme / extend-syntax.scm.‾1‾ < prev    next >
Encoding:
Text File  |  1993-07-16  |  11.8 KB  |  406 lines
  1. ;;; extend-syntax.scm
  2. ;;; August 7, 1989
  3. ;;; Ported from chez to mitscheme M. Radle, M. Montenyohl and E. Elberson
  4. ;;; new macros include:  when, unless,  and
  5. ;;; kerror ('k' to differentiate from mitscheme's 'error' function.)
  6. ;;; The following functions were added:
  7. ;;;  gensym, duplicate-symbols, box, unbox, set-box!.
  8. ;;; April 15, 1991 (markf@zurich.ai.mit.edu)
  9. ;;; Added define-macro-both to define macros in this file and in
  10. ;;; user-initial-syntax-table.
  11.  
  12. (syntax-table-define user-initial-syntax-table 'define-both
  13.   (macro (pattern . body)
  14.     `(begin
  15.        (define-macro ,pattern ,@body)
  16.        (syntax-table-define user-initial-syntax-table ',(car pattern)
  17.      (macro ,(cdr pattern)
  18.        ,@body)))))
  19.  
  20. (define gensym generate-uninterned-symbol)
  21.  
  22. (define gensym generate-uninterned-symbol)
  23.  
  24. (define-both (unless *cond . e1 ) `(if (not ,*cond) (begin ,@e1) #f))
  25.  
  26. (define-both (when *cond . e1) `(if ,*cond (begin ,@e1) #f))
  27.  
  28. (define-macro (kerror msg-line . args)
  29.   `(begin
  30.      (format ,msg-line ,@args)
  31.      (error " ")))
  32.  
  33.  
  34.  
  35. ;;; extend.ss
  36. ;;; Copyright (C) 1987 R. Kent Dybvig
  37. ;;; Permission to copy this software, in whole or in part, to use this
  38. ;;; software for any lawful purpose, and to redistribute this software
  39. ;;; is granted subject to the restriction that all copies made of this
  40. ;;; software must include this copyright notice in full.
  41.  
  42. ;;; The basic design of extend-syntax is due to Eugene Kohlbecker.  See
  43. ;;; "E. Kohlbecker: Syntactic Extensions in the Programming Language Lisp",
  44. ;;; Ph.D.  Dissertation, Indiana University, 1986."  The structure of "with"
  45. ;;; pattern/value clauses, the method for compiling extend-syntax into
  46. ;;; Scheme code, and the actual implementation are due to Kent Dybvig.
  47.  
  48.  
  49. ;;; August 7, 1989
  50. ;;; We modified Kent's original code as follows:
  51. ;;;     . use define-macro to define extend-syntax
  52. ;;;    . All 'defines' are nested inside the definition of extend-syntax.
  53. ;;;    . Syntax-Match? had to be defined local to extend-syntax's definition
  54. ;;;       and local to the call to define-macro that appears in the 
  55. ;;;      expansion for extend-syntax. (see bottom of file).
  56. ;;; April 15, 1991 (markf@zurich.ai.mit.edu)
  57. ;;; Use syntax-table-define instead of define-macro.
  58. ;;; Put syntax-match in the proper place.
  59.  
  60. (syntax-table-define user-initial-syntax-table 'extend-syntax
  61.   (macro (keys . clauses)
  62.  
  63.     (define gensym generate-uninterned-symbol)
  64.     (define box (lambda (x) (cons x #f)))
  65.     (define unbox (lambda (x) (car x)))
  66.     (define set-box! (lambda (x v) (set-car! x v)))
  67.     
  68.     (define duplicate-symbols
  69.       (lambda ( list )
  70.     (unless (null? list)
  71.         (when (memq (car list) (cdr list))
  72.               (cons (car list)
  73.                 ( duplicate-symbols (cdr list)))))))
  74.  
  75.  
  76.  
  77.     (define id
  78.       (lambda (name *access control)
  79.     (list name *access control)))
  80.     (define id-name car)
  81.     (define id-access cadr)
  82.     (define id-control caddr)
  83.  
  84.     (define loop
  85.       (lambda ()
  86.     (box '())))
  87.     (define loop-ids unbox)
  88.     (define loop-ids! set-box!)
  89.  
  90.     (define c...rs
  91.       `((car caar . cdar)
  92.         (cdr cadr . cddr)
  93.         (caar caaar . cdaar)
  94.         (cadr caadr . cdadr)
  95.         (cdar cadar . cddar)
  96.         (cddr caddr . cdddr)
  97.         (caaar caaaar . cdaaar)
  98.         (caadr caaadr . cdaadr)
  99.         (cadar caadar . cdadar)
  100.         (caddr caaddr . cdaddr)
  101.         (cdaar cadaar . cddaar)
  102.         (cdadr cadadr . cddadr)
  103.         (cddar caddar . cdddar)
  104.         (cdddr cadddr . cddddr)))
  105.  
  106.     (define add-car
  107.       (lambda (*access)
  108.     (let ((x (and (pair? *access) (assq (car *access) c...rs))))
  109.       (if (null? x)
  110.           `(car ,*access)
  111.           `(,(cadr x) ,@(cdr *access))))))
  112.  
  113.     (define add-cdr
  114.       (lambda (*access)
  115.     (let ((x (and (pair? *access) (assq (car *access) c...rs))))
  116.       (if (null? x)
  117.           `(cdr ,*access)
  118.           `(,(cddr x) ,@(cdr *access))))))
  119.  
  120.  
  121.     (define checkpat
  122.       (lambda (keys pat exp)
  123.     (let ((vars (let f ((x pat) (vars '()))
  124.               (cond
  125.                ((pair? x)
  126.             (if (and (pair? (cdr x))
  127.                  (eq? (cadr x) '...)
  128.                  (null? (cddr x)))
  129.                 (f (car x) vars)
  130.                 (f (car x) (f (cdr x) vars))))
  131.                ((symbol? x)
  132.             (cond
  133.              ((memq x keys) vars)
  134.              ((or (eq? x 'with) (eq? x '...))
  135.               (kerror
  136.                "EXTEND-SYNTAX: Invalid context for ~o in ~o"
  137.                x exp))
  138.              (else (cons x vars))))
  139.                (else vars)))))
  140.       (let ((dupls (duplicate-symbols vars)))
  141.         (unless (null? dupls)
  142.             (kerror "EXTEND-SYNTAX: duplicate pattern variable name ~o in ~o"
  143.                 (car dupls) exp))))))
  144.  
  145.     (define parse
  146.       (lambda (keys pat acc cntl ids)
  147.     (cond
  148.      ((symbol? pat)
  149.       (if (memq pat keys)
  150.           ids
  151.           (cons (id pat acc cntl) ids)))
  152.      ((pair? pat)
  153.       (cons (id pat acc cntl)
  154.         (if (equal? (cdr pat) '(...))
  155.             (let ((x (gensym)))
  156.               (parse keys (car pat) x (id x acc cntl) ids))
  157.             (parse keys (car pat) (add-car acc) cntl
  158.                (parse keys (cdr pat) (add-cdr acc) cntl ids)))))
  159.      (else ids))))
  160.  
  161.     (define pattern-variable?
  162.       (lambda (sym ids)
  163.     (memq sym (map id-name ids))))
  164.  
  165.     (define gen
  166.       (lambda (keys exp ids loops qqlev)
  167.     (cond
  168.      ((lookup exp ids) =>
  169.                (lambda (id)
  170.                  (add-control! (id-control id) loops)
  171.                  (list 'unquote (id-access id))))
  172.      ((not (pair? exp)) exp)
  173.      (else
  174.       (cond
  175.        ((and (syntax-match? '(quasiquote *) exp)
  176.          (not (pattern-variable? 'quasiqote ids)))
  177.         (list 'unquote
  178.           (list 'list
  179.             ''quasiquote
  180.             (make-quasi
  181.              (gen keys (cadr exp) ids loops
  182.                   (if (= qqlev 0) 0 (+ qqlev 1)))))))
  183.        ((and (syntax-match? '(* *) exp)
  184.          (memq (car exp) '(unquote unquote-splicing))
  185.          (not (pattern-variable? (car exp) ids)))
  186.         (list 'unquote
  187.           (list 'list
  188.             (list 'quote (car exp))
  189.             (make-quasi
  190.              (if (= qqlev 1)
  191.                  (gen-quotes keys (cadr exp) ids loops)
  192.                  (gen keys (cadr exp) ids loops
  193.                   (- qqlev 1)))))))
  194.        ((and (eq? (car exp) 'with)
  195.          (not (pattern-variable? 'with ids)))
  196.         (unless (syntax-match? '(with ((* *) ...) *) exp)
  197.                     (kerror "EXTEND-SYNTAX: invalid 'with' form ~o" exp))
  198.         (checkpat keys (map car (cadr exp)) exp)
  199.         (list 'unquote
  200.           (gen-with
  201.            keys
  202.            (map car (cadr exp))
  203.            (map cadr (cadr exp))
  204.            (caddr exp)
  205.            ids
  206.            loops)))
  207.        ((and (pair? (cdr exp)) (eq? (cadr exp) '...))
  208.         (let ((x (loop)))
  209.           (gen-cons (list 'unquote-splicing
  210.                   (make-loop x (gen keys (car exp) ids
  211.                         (cons x loops) qqlev)))
  212.             (gen keys (cddr exp) ids loops qqlev))))
  213.        (else
  214.         (gen-cons (gen keys (car exp) ids loops qqlev)
  215.               (gen keys (cdr exp) ids loops qqlev))))))))
  216.  
  217.     (define gen-cons
  218.       (lambda (head tail)
  219.     (if (null? tail)
  220.         (if (syntax-match? '(unquote-splicing *) head)
  221.         (list 'unquote (cadr head))
  222.         (cons head tail))
  223.         (if (syntax-match? '(unquote *) tail)
  224.         (list head (list 'unquote-splicing (cadr tail)))
  225.         (cons head tail)))))
  226.  
  227.     (define gen-with
  228.       (lambda (keys pats exps body ids loops)
  229.     (let ((temps (map (lambda (x) (gensym)) pats)))
  230.       `(let (,@(map (lambda (t e) `(,t ,(gen-quotes keys e ids loops)))
  231.             temps
  232.             exps))
  233.          ,@(let f ((pats pats) (temps temps))
  234.          (if (null? pats)
  235.              '()
  236.              (let ((m (match-pattern '() (car pats)))
  237.                (rest (f (cdr pats) (cdr temps))))
  238.                (if (eq? m '*)
  239.                (f (cdr pats) (cdr temps))
  240.                `((unless (syntax-match? ',m ,(car temps))
  241.                                      (kerror "~o: ~o does not fit 'with' pattern ~o"
  242.                          ',(car keys)
  243.                          ,(car temps)
  244.                          ',(car pats)))
  245.                  ,@(f (cdr pats) (cdr temps)))))))
  246.          ,(let f ((pats pats) (temps temps) (ids ids))
  247.         (if (null? pats)
  248.             (make-quasi (gen keys body ids loops 0))
  249.             (f (cdr pats)
  250.                (cdr temps)
  251.                (parse '() (car pats) (car temps) '() ids))))))))
  252.  
  253.     (define gen-quotes
  254.       (lambda (keys exp ids loops)
  255.     (cond
  256.      ((syntax-match? '(quote *) exp)
  257.       (make-quasi (gen keys (cadr exp) ids loops 0)))
  258.      ((syntax-match? '(quasiquote *) exp)
  259.       (make-quasi (gen keys (cadr exp) ids loops 1)))
  260.      ((pair? exp)
  261.       (let f ((exp exp))
  262.         (if (pair? exp)
  263.         (cons (gen-quotes keys (car exp) ids loops)
  264.               (f (cdr exp)))
  265.         (gen-quotes keys exp ids loops))))
  266.      (else exp))))
  267.  
  268.     (define lookup
  269.       (lambda (exp ids)
  270.     (let loop ((ls ids))
  271.       (cond
  272.        ((null? ls) #f)
  273.        ((equal? (id-name (car ls)) exp) (car ls))
  274.        ((subexp? (id-name (car ls)) exp) #f)
  275.        (else (loop (cdr ls)))))))
  276.  
  277.     (define subexp?
  278.       (lambda (exp1 exp2)
  279.     (and (symbol? exp1)
  280.          (let f ((exp2 exp2))
  281.            (or (eq? exp1 exp2)
  282.            (and (pair? exp2)
  283.             (or (f (car exp2))
  284.                 (f (cdr exp2)))))))))
  285.  
  286.     (define add-control!
  287.       (lambda (id loops)
  288.     (unless (null? id)
  289.         (when (null? loops)
  290.               (kerror "EXTEND-SYNTAX: missing ellipsis in expansion"))
  291.         (let ((x (loop-ids (car loops))))
  292.           (unless (memq id x)
  293.               (loop-ids! (car loops) (cons id x))))
  294.         (add-control! (id-control id) (cdr loops)))))
  295.  
  296.     (define make-loop
  297.       (lambda (loop body)
  298.     (let ((ids (loop-ids loop)))
  299.       (when (null? ids)
  300.         (kerror "EXTEND-SYNTAX: extra ellipsis in expansion"))
  301.       (cond
  302.        ((equal? body (list 'unquote (id-name (car ids))))
  303.         (id-access (car ids)))
  304.        ((and (null? (cdr ids))
  305.          (syntax-match? '(unquote (* *)) body)
  306.          (eq? (cadadr body) (id-name (car ids))))
  307.         `(map ,(caadr body) ,(id-access (car ids))))
  308.        (else
  309.         `(map (lambda ,(map id-name ids) ,(make-quasi body))
  310.           ,@(map id-access ids)))))))
  311.  
  312.     (define match-pattern
  313.       (lambda (keys pat)
  314.     (cond
  315.      ((symbol? pat)
  316.       (if (memq pat keys)
  317.           (if (memq pat '(* \\ ...))
  318.           `(\\ ,pat)
  319.           pat)
  320.           '*))
  321.      ((pair? pat)
  322.       (if (and (pair? (cdr pat))
  323.            (eq? (cadr pat) '...)
  324.            (null? (cddr pat)))
  325.           `(,(match-pattern keys (car pat)) ...)
  326.           (cons (match-pattern keys (car pat))
  327.             (match-pattern keys (cdr pat)))))
  328.      (else pat))))
  329.          
  330.     (define make-quasi
  331.       (lambda (exp)
  332.     (if (and (pair? exp) (eq? (car exp) 'unquote))
  333.         (cadr exp)
  334.         (list 'quasiquote exp))))
  335.  
  336.  
  337.  
  338.  
  339.     (define make-clause
  340.       (lambda (keys cl x)
  341.     (cond
  342.      ((syntax-match? '(* * *) cl)
  343.       (let ((pat (car cl)) (fender (cadr cl)) (exp (caddr cl)))
  344.         (checkpat keys pat pat)
  345.         (let ((ids (parse keys pat x '() '())))
  346.           `((and (syntax-match? ',(match-pattern keys pat) ,x)
  347.              ,(gen-quotes keys fender ids '()))
  348.         ,(make-quasi (gen keys exp ids '() 0))))))
  349.      ((syntax-match? '(* *) cl)
  350.       (let ((pat (car cl)) (exp (cadr cl)))
  351.         (checkpat keys pat pat)
  352.         (let ((ids (parse keys pat x '() '())))
  353.           `((syntax-match? ',(match-pattern keys pat) ,x)
  354.         ,(make-quasi (gen keys exp ids '() 0))))))
  355.      (else
  356.       (kerror "EXTEND-SYNTAX: invalid clause ~o" cl)))))
  357.  
  358.     (define make-syntax
  359.       (let ((x (string->uninterned-symbol "x")))
  360.     (lambda (keys clauses)
  361.       (when (memq '... keys)
  362.         (kerror "EXTEND-SYNTAX: invalid keyword ... in keyword list ~o"
  363.             keys))
  364.       `(lambda (,x)
  365.          (cond
  366.           ,@(map (lambda (cl) (make-clause keys cl x)) clauses)
  367.           (else
  368.            (kerror "~o: invalid syntax ~o" ',(car keys) ,x)))
  369.          ))))
  370.  
  371.  
  372.  
  373.     `(define-both (,(car keys) . body)
  374.  
  375.        (,(make-syntax keys clauses)  (cons ',(car keys) body)))))
  376.  
  377.  
  378.  
  379. (define syntax-match?
  380.    (lambda (pat exp)
  381.       (or (eq? pat '*)
  382.           (eq? exp pat)
  383.           (and (pair? pat)
  384.                (cond
  385.                   ((and (eq? (car pat) '\\)
  386.                         (pair? (cdr pat))
  387.                         (null? (cddr pat)))
  388.                    (eq? exp (cadr pat)))
  389.                   ((and (pair? (cdr pat))
  390.                         (eq? (cadr pat) '...)
  391.                         (null? (cddr pat)))
  392.                    (let ((pat (car pat)))
  393.                       (let f ((lst exp))
  394.                          (or (null? lst)
  395.                              (and (pair? lst)
  396.                                   (syntax-match? pat (car lst))
  397.                                   (f (cdr lst)))))))
  398.                   (else
  399.                    (and (pair? exp)
  400.                         (syntax-match? (car pat) (car exp))
  401.                         (syntax-match? (cdr pat) (cdr exp)))))))))
  402.  
  403.  
  404. (local-assignment syntaxer/default-environment
  405.           'syntax-match?
  406.           syntax-match?)